Shareware Grab Bag/Shareware Grab Bag.iso/007/fd.arc/FD.PAS

Pascal/Delphi Source File | 1986-12-30 | 12.5 KB | 464 lines

PROGRAM  SortedDirectory;

{ file:  FD.PAS }

{**************************************************************}
{                                                              }
{ Authored by:   Robert Shaw                                   }
{                5580 North 180th Street                       }
{                Hugo, Minn  55038                             }
{                612-464-1435                                  }
{                                                              }
{ This program was written to provide a fast and easily        }
{ readable directory utilizing a color display.                }
{                                                              }
{ FD will allow directories of any valid path without regard   }
{ to which directory is current.                               }
{                                                              }
{ Directories greater than 115 entries are paged such that     }
{ all entries are truly in sequence on each viewing page.      }
{                                                              }
{**************************************************************}


{**************************************************************}
{ turbo directives                                             }
{**************************************************************}

{$C-}
{$U-}
{$R-}
{$K-}
{$V-}

{**************************************************************}
{ declarations                                                 }
{**************************************************************}

TYPE
  String80  = STRING[80];

  KeyRec    = RECORD
                name      : STRING[12];
                ext       : STRING[4];
                dirattrib : BOOLEAN;
              END;

  FileList  = ARRAY[1..768] OF KeyRec;

  Registers = RECORD
                CASE INTEGER OF
                  1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,FLAGS : INTEGER);
                  2: (AL,AH,BL,BH,CL,CH,DL,DH : BYTE);
                END;

VAR
  reg        : Registers;
  list       : FileList;
  mask       : String[62];
  currentdir : String[62];
  heading    : String80;
  total      : INTEGER;
  mono       : BOOLEAN;
  tempchar   : CHAR;


{**************************************************************}
{ support procedures                                           }
{**************************************************************}

PROCEDURE  WriteBrite( text  : String80 );
BEGIN
  TextColor(Yellow);
  Write(text);
  TextColor(Cyan);
END;



PROCEDURE  Bleep(times : BYTE );
VAR
  i : BYTE;
BEGIN
  FOR i := 1 to times DO BEGIN
    Sound(880);
    Delay(60);
    Sound(440);
    Delay(60);
    NoSound;
  END;
END;



PROCEDURE  DisplayError( error : BYTE );
VAR
  prompt : String80;
BEGIN
  CASE error OF
    1 : prompt := 'invalid or none';
    2 : prompt := 'invalid parameters';
  END;
  WriteLn(prompt);
  Bleep(1);
  Halt;
END;



PROCEDURE  StringUpperCase (VAR Strg : String80);
  {convert string to uppercase}
BEGIN
  INLINE
  ($C4/$BE/Strg/                {       LES    DI, Strg[BP]            }
   $26/$8A/$0D/                 {       MOV    CL, ES:DI               }
   $FE/$C1/                     {       INC    CL                      }
   $FE/$C9/                     { L1:   DEC    CL                      }
   $74/$13/                     {       JZ     L2                      }
   $47/                         {       INC    DI                      }
   $26/$80/$3D/$61/             {       CMP    ES:BYTE PTR [DI], 'a'   }
   $72/$F5/                     {       JB     L1                      }
   $26/$80/$3D/$7A/             {       CMP    ES:BYTE PTR [DI], 'z'   }
   $77/$EF/                     {       JA     L1                      }
   $26/$80/$2D/$20/             {       SUB    ES:BYTE PTR [DI], 20H   }
   $EB/$E9);                    {       JMP    SHORT L1                }
                                { L2:                                  }
END;



PROCEDURE  Print(col    : BYTE     ;
                 row    : BYTE     ;
                 text   : String80 ;
                 attrib : BYTE    );
BEGIN
  IF mono THEN attrib := $07;
  INLINE
    ($1E/$1E/$8A/$86/row/$B3/$50/$F6/$E3/$2B/$DB/$8A/$9E/col/
     $03/$C3/$03/$C0/$8B/$F8/$be/$00/$00/$8A/$BE/attrib/
     $8a/$8e/text/$22/$c9/$74/$3e/$2b/$c0/$8E/$D8/$A0/$49/$04/
     $1F/$2C/$07/$74/$22/$BA/$00/$B8/$8E/$DA/$BA/$DA/$03/$46/
     $8a/$9A/text/$EC/$A8/$01/$75/$FB/$FA/$EC/$A8/$01/$74/$FB/
     $89/$1D/$47/$47/$E2/$Ea/$2A/$C0/$74/$10/$BA/$00/$B0/
     $8E/$DA/$46/$8a/$9A/text/$89/$1D/$47/$47/$E2/$F5/$1F);
END;

{**************************************************************}
{ sort directory files array                                   }
{**************************************************************}

PROCEDURE  SortDirectory;
VAR
  i      : INTEGER;
  j      : INTEGER;
  k      : INTEGER;
  spread : INTEGER;
  temp   : KeyRec;
BEGIN
  spread := total DIV 2;
  WHILE spread > 0 DO BEGIN
    FOR i := spread + 1 TO total DO BEGIN
      j := i - spread;
      WHILE j > 0 DO BEGIN
        k := j + spread;
        IF list[j].name <= list[k].name THEN
          j := 0
        ELSE BEGIN
          temp    := list[j];
          list[j] := list[k];
          list[k] := temp;
        END;
        j := j - spread
      END
    END;
    spread := spread DIV 2;
  END;
END;

{**************************************************************}
{ search directory                                             }
{**************************************************************}

PROCEDURE  ReadDirectory;
CONST
  dta : STRING[44] = '                                            ';


  PROCEDURE  FillRecord;
  VAR
    dotlocation : BYTE;
  BEGIN
    total := SUCC(total);
    WITH list[total] DO BEGIN
      name := COPY(dta, 31, 12);
      ext  := '';
      dirattrib := ((ORD(dta[22]) AND 16) = 16);

      IF NOT dirattrib THEN BEGIN
        dotlocation := POS('.', name);
        IF ( dotlocation > 0 ) THEN BEGIN
          ext := COPY(name, dotlocation, 4);
          name[0] := CHR(dotlocation - 1);
        END;
      END;
    END;
  END;



BEGIN
  total := 0;
  mask[LENGTH(mask)+1] := #00;

  reg.AH := $1A;
  reg.DS := SEG(dta);
  reg.DX := OFS(dta) + 1;
  MSDos(reg);

  reg.AH := $4E;
  reg.DS := SEG(mask);
  reg.DX := OFS(mask) + 1;
  reg.CX := 23;
  MSDos(reg);

  IF (reg.FLAGS AND 1) = 0 THEN BEGIN

    FillRecord;

    REPEAT
      FillChar(dta[31], 14, #00);

      reg.AH := $4F;
      MSDos(reg);

      IF ( reg.AX <> 18 ) THEN FillRecord;

    UNTIL ODD(reg.FLAGS AND 1);

  END ELSE
    DisplayError(1);
END;

{**************************************************************}
{ display sorted files                                         }
{**************************************************************}

PROCEDURE  DisplayDirectory;
VAR
  subtotal  : INTEGER;
  k         : INTEGER;
  span      : BYTE;
  index     : BYTE;
  row       : BYTE;
  pagecount : BYTE;
  page      : BYTE;
  start     : BYTE;


  PROCEDURE  PrintHeading;
  BEGIN
    ClrScr;
    Print(0,0,heading,Yellow);
    row := 1;
  END;


  PROCEDURE  PrintRecord(  col : BYTE  ;
                         index : BYTE );
  BEGIN
    WITH list[index] DO BEGIN
      IF dirattrib THEN BEGIN
        Print(col, row, name, White);
        Print(col+8, row, '<DIR>', Green);
      END ELSE BEGIN
        Print(col, row, name, Cyan);
        Print(col+8, row, ext, Brown);
      END;
    END;
  END;



BEGIN
  FOR k := total+1 TO total+6 DO BEGIN
    WITH list[k] DO BEGIN
      name := '';
      ext  := '';
      dirattrib := FALSE;
    END;
  END;

  heading := 'Directory:  ' + mask;
  IF POS('\*.*', heading) > 0 THEN
    heading := COPY(heading, 1, POS('\*.*',heading)-1);

  IF (total > 115) THEN BEGIN
    start := 1;
    span := 23;
    pagecount := total DIV 115;
    IF (pagecount * 115) <> total THEN pagecount := SUCC(pagecount);

    FOR page := 1 TO pagecount DO BEGIN
      PrintHeading;
      FOR index := start TO span+start-1 DO BEGIN

        PrintRecord( 0, index);
        PrintRecord(16, index + span);
        PrintRecord(32, index + (span * 2));
        PrintRecord(48, index + (span * 3));
        PrintRecord(64, index + (span * 4));

        row := SUCC(row);
      END;

      IF row = 24 THEN BEGIN
        Print(0,24,'press any key', White);
        GotoXY(14,25);
        Read(kbd, tempchar);
      END;

      start := (page * 115) + 1;
      subtotal := total - (page * 115);
      IF subtotal < 116 THEN BEGIN
        span := subtotal DIV 5;
        IF (span * 5) <> subtotal THEN span := SUCC(span);
      END;
    END;

  END ELSE BEGIN

    PrintHeading;

    span := total DIV 5;
    IF (span * 5) <> total THEN span := SUCC(span);

    FOR index := 1 TO span DO BEGIN

      PrintRecord( 0, index);
      PrintRecord(16, index + span);
      PrintRecord(32, index + (span * 2));
      PrintRecord(48, index + (span * 3));
      PrintRecord(64, index + (span * 4));

      row := SUCC(row);
    END;
  END;

  GotoXY(1,row+1);
END;

{**************************************************************}
{ help display                                                 }
{**************************************************************}

PROCEDURE  DisplayHelp;
BEGIN
  ClrScr;
  WriteBrite('FD');
  Write(' - ');
  WriteBrite('F');
  Write('ast ');
  WriteBrite('D');
  WriteLn('irectory            (version 12.29)');
  WriteLn;
  WriteLn('Fast color display of tabulated sorted directory.');
  WriteLn;
  WriteBrite('Usage:');
  WriteLn('   FD [path | /h]');
  WriteLn;
  WriteBrite('Option:');
  WriteLn('  path - any valid path');
  WriteLn('         /h   - display help screen');
  WriteLn;
  WriteLn;
  WriteBrite('Author:');
  WriteLn('  Robert Shaw');
  WriteLn('         5580 North 180th Street');
  WriteLn('         Hugo, MN 55038');
  WriteLn;
  Halt;
END;

{**************************************************************}
{ parameters and set path                                      }
{**************************************************************}

PROCEDURE  ParseParameters;
BEGIN
  IF MEM[$0000:$0449] = $07 THEN mono := TRUE ELSE mono := FALSE;

  IF ParamCount > 1 THEN DisplayError(2);

  IF ParamStr(1) = '/h' THEN DisplayHelp;

  IF ParamCount = 1 THEN mask := ParamStr(1) ELSE mask := '*.*';

  IF (POS('..',mask)=(LENGTH(mask)-1)) AND (mask[0]>#1) THEN
    mask := mask + '\';

  tempchar := mask[LENGTH(mask)];

  IF (tempchar=':') OR (tempchar='\') THEN mask := mask + '*.*';

  IF mask[2] <> ':' THEN BEGIN
    reg.AH := $19;
    MSDos(reg);
    mask := CHR(reg.AL+65) + ':' + mask;
  END;

  IF mask[3] <> '\' THEN BEGIN
    GetDir(ORD(mask[1])-64, currentdir);
    IF LENGTH(currentdir) <> 3 THEN currentdir := currentdir + '\';
    mask := currentdir + COPY(mask, 3, LENGTH(mask));
  END;

  StringUpperCase(mask);
END;

{**************************************************************}
{ main                                                         }
{**************************************************************}

BEGIN
  ParseParameters;
  ReadDirectory;

  IF ( list[1].dirattrib ) AND
             ( total = 1 ) THEN BEGIN
    mask := mask + '\*.*';
    ReadDirectory;
  END;

  SortDirectory;
  DisplayDirectory;
END.

{**************************************************************}
{ revision history                                             }
{**************************************************************}

12.29.86 - creation


{**************************************************************}
{ limitations                                                  }
{**************************************************************}

- maximum of 768 directory entries, no checking
- displays only filename and extension, size, date
  and time was not in design criteria

{**************************************************************}
{ future enhancements                                          }
{**************************************************************}

- spiffy up parsing of path
- no page option may be nice?

{**************************************************************}
{ known bugs                                                   }
{**************************************************************}

- doesn't restore cursor color upon exit